home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / packages / backup-dir.el.z / backup-dir.el
Encoding:
Text File  |  1998-05-21  |  18.6 KB  |  468 lines
  1. ;;; BACKUP-DIR.EL:   Emacs functions to allow backup files to live in
  2. ;;;                  some other directory(s).             Version 2.0
  3. ;;;
  4. ;;; Copyright (C) 1992-97 Greg Klanderman
  5. ;;;
  6. ;;; This program is free software; you can redistribute it and/or modify
  7. ;;; it under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 1, or (at your option)
  9. ;;; any later version.
  10. ;;;
  11. ;;; This program is distributed in the hope that it will be useful,
  12. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; A copy of the GNU General Public License can be obtained from
  17. ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
  18. ;;; 02139, USA.
  19. ;;;
  20. ;;; Send bug reports, etc. to greg@alphatech.com or gregk@ai.mit.edu.
  21. ;;;
  22. ;;;
  23. ;;; Modification History
  24. ;;; ====================
  25. ;;;
  26. ;;; 12/28/1996  Version 2.0
  27. ;;; Updated for XEmacs 19.15b4, much of code reorganized & cleaned up
  28. ;;;
  29. ;;; 12/27/1996  Version 1.6
  30. ;;; explicit loading of dired replaced to use dired-load-hook
  31. ;;; (suggested by Thomas Feuster, feuster@tp4.physik.uni-giessen.de)
  32. ;;;
  33. ;;; 12/2/1996 Version 1.5
  34. ;;; Took out obsolete byte compiler options
  35. ;;;
  36. ;;; 9/24/1996 Version 1.4
  37. ;;; Fix some bugs, change to alist OPTIONS list (ok-create, full-path..) from
  38. ;;; separate fields for each option variable.  Added search-upward option.
  39. ;;; Added new function `find-file-latest-backup' to find a file's latest backup.
  40. ;;;
  41. ;;; 1/26/1996 Version 1.3
  42. ;;; Name change to backup-dir.el
  43. ;;;
  44. ;;; 3/22/1995 Version 1.2
  45. ;;; Added new definitions for functions `file-newest-backup', `latest-backup-file',
  46. ;;; and `diff-latest-backup-file' so various other emacs functions will find the
  47. ;;; right backup files.
  48. ;;;
  49. ;;; 4/23/1993 Version 1.1
  50. ;;; Reworked to allow different behavior for different files based on the
  51. ;;; alist `bkup-backup-directory-info'.
  52. ;;;
  53. ;;; Fall 1992 Version 1.0
  54. ;;; Name change and added ability to make directories absolute.  Added the
  55. ;;; full path stuff to make backup name unique for absolute directories.
  56. ;;;
  57. ;;; Spring 1992 Version 0.0
  58. ;;; Original
  59. ;;;
  60. ;;;
  61. ;;; Description:
  62. ;;; ============
  63. ;;;
  64. ;;; Allows backup files to be optionally stored in some directories, based on
  65. ;;; the value of the alist, `bkup-backup-directory-info'.  This variable is a
  66. ;;; list of lists of the form (FILE-REGEXP BACKUP-DIR OPTIONS ...).  If the
  67. ;;; filename to be backed up matches FILE-REGEXP, or FILE-REGEXP is t, then
  68. ;;; BACKUP-DIR is used as the path for its backups.  Directories may begin with
  69. ;;; "/" to specify an absolute pathname.  If BACKUP-DIR does not exist and
  70. ;;; OPTIONS contains the symbol `ok-create', then it is created if possible.
  71. ;;; Otherwise the usual behavior (backup in the same directory as the file)
  72. ;;; results.  If OPTIONS contains the symbol `full-path', then the full path of
  73. ;;; the file being backed up is prepended to the backup file name, with each "/"
  74. ;;; replaced by a "!".  This is intended for cases where an absolute backup path
  75. ;;; is used.  If OPTIONS contains the symbol `search-upward' and the backup
  76. ;;; directory BACKUP-DIR is a relative path, then a directory with that name is
  77. ;;; searched for starting at the current directory and proceeding upward (..,
  78. ;;; ../.., etc) until one is found of that name or the root is reached, and if
  79. ;;; one is found it is used as the backup directory.  Finally, if no FILE-REGEXP
  80. ;;; matches the file name being backed up, then the usual behavior results.
  81. ;;;
  82. ;;; These lines from my .emacs load this file and set the values I like:
  83. ;;;
  84. ;;; (require 'backup-dir)
  85. ;;; (setq bkup-backup-directory-info
  86. ;;;       '(("/home/greg/.*" "/~/.backups/" ok-create full-path)
  87. ;;;        (t                ".backups/"    full-path search-upward)))
  88. ;;;
  89. ;;;
  90. ;;; The package also provides a new function, `find-file-latest-backup' to find
  91. ;;; the latest backup file for the current buffer's file.
  92. ;;;
  93. ;;;
  94. ;;; This file is based on `files.el' from XEmacs 19.15b4.
  95. ;;; It has not been extensively tested on GNU Emacs past 18.58.
  96. ;;; It does not work under ms-dos.
  97.  
  98.  
  99. (byte-compiler-options
  100.  (optimize t)
  101.  (warnings (- free-vars))              ; Don't warn about free variables
  102.  )
  103.  
  104.  
  105. ;;; New variables affecting backup file behavior
  106. ;;; This is the only user-customizable variable for this package.
  107. ;;;
  108. (defcustom bkup-backup-directory-info nil
  109.   "*Alist of (FILE-REGEXP BACKUP-DIR OPTIONS ...))
  110. If the filename to be backed up matches FILE-REGEXP, or FILE-REGEXP is t,
  111. then BACKUP-DIR is used as the path for its backups.
  112.  
  113. Directories may begin with \"/\" to specify an absolute pathname.
  114.  
  115. If BACKUP-DIR does not exist and OPTIONS contains the symbol `ok-create',
  116. then it is created if possible.  Otherwise the usual behavior (backup in the
  117. same directory as the file) results.
  118.  
  119. If OPTIONS contains the symbol `full-path', then the full path of the file
  120. being backed up is prepended to the backup file name, with each \"/\"
  121. replaced by a \"!\".  This is intended for cases where an absolute backup
  122. path is used.
  123.  
  124. If OPTIONS contains the symbol `search-upward' and the backup directory
  125. BACKUP-DIR is a relative path, then a directory with that name is searched
  126. for starting at the current directory and proceeding upward (.., ../.., etc)
  127. until one is found of that name, or the root is reached, and if one is found
  128. it is used as the backup directory.
  129.  
  130. Finally, if no FILE-REGEXP matches the file name being backed up, then the
  131. usual behavior results.
  132.  
  133. Once you save this variable with `M-x customize-variable',
  134. `backup-dir' will  be loaded for you each time you start XEmacs."
  135.   :type '(repeat 
  136.       (list (regexp :tag "File regexp")
  137.         (string :tag "Backup Dir")
  138.         (set :inline t
  139.              (const ok-create)
  140.              (const full-path)
  141.              (const search-upward))))
  142.   :require 'backup-dir
  143.   :group 'backup)
  144.  
  145. ;;; New functions
  146. ;;;
  147. (defun bkup-search-upward-for-backup-dir (base bd-name)
  148.   "search upward for a directory named BD-NAME, starting in the
  149. directory BASE and continuing with its parent directories until
  150. one is found or the root is reached."
  151.   (let ((prev nil) (curr base) (gotit nil) (tryit nil))
  152.     (while (and (not gotit)
  153.                 (not (equal prev curr))
  154.                 (not (equal curr "//")))
  155.       (setq prev curr)
  156.       (setq curr (expand-file-name (concat curr "../")))
  157.       (setq tryit (expand-file-name bd-name curr))
  158.       (if (and (file-directory-p tryit) (file-exists-p tryit))
  159.           (setq gotit tryit)))
  160.     (if (and gotit
  161.              (eq (aref gotit (1- (length gotit))) ?/))
  162.         (setq gotit (substring gotit 0 (1- (length gotit)))))
  163.     gotit)) 
  164.  
  165. (defun bkup-replace-slashes-with-exclamations (s)
  166.   "Replaces slashes in the string S with exclamations.
  167. A new string is produced and returned."
  168.   (let ((ns (copy-sequence s))
  169.     (i (1- (length s))))
  170.     (while (>= i 0)
  171.       (if (= (aref ns i) ?/)
  172.       (aset ns i ?!))
  173.       (setq i (1- i)))
  174.     ns))
  175.  
  176. (defun bkup-try-making-directory (dir)
  177.   "try making directory DIR, return non-nil if successful"
  178.   (condition-case ()
  179.       (progn (make-directory dir t)
  180.              t)
  181.     (t
  182.      nil)))
  183.   
  184. (defun bkup-backup-basename (file full-path)
  185.   "Gives the base part of the backup name for FILE, according to FULL-PATH."
  186.   (if full-path
  187.       (bkup-replace-slashes-with-exclamations file)
  188.     (file-name-nondirectory file)))
  189.  
  190. (defun bkup-backup-directory-and-basename (file)
  191.   "Return the cons of the backup directory name
  192. and backup file name base for FILE."
  193.   (let ((file (expand-file-name file)))
  194.     (let ((dir     (file-name-directory file))
  195.           (alist   bkup-backup-directory-info)
  196.           (bk-dir  nil)
  197.           (bk-base nil))
  198.       (if (listp alist)
  199.           (while (and (not bk-dir) alist)
  200.             (if (or (eq (car (car alist)) t)
  201.                     (eq (string-match (car (car alist)) file) 0))
  202.                 (let* ((bd            (car (cdr (car alist))))
  203.                        (bd-rel-p      (and (> (length bd) 0)
  204.                                            (not (eq (aref bd 0) ?/))))
  205.                        (bd-expn       (expand-file-name bd dir))
  206.                        (bd-noslash    (if (eq (aref bd-expn (1- (length bd-expn))) ?/)
  207.                                           (substring bd-expn 0 (1- (length bd-expn)))
  208.                                         bd-expn))
  209.                        (options       (cdr (cdr (car alist))))
  210.                        (ok-create     (and (memq 'ok-create     options) t))
  211.                        (full-path     (and (memq 'full-path     options) t))
  212.                        (search-upward (and (memq 'search-upward options) t)))
  213.                   (if bd-expn
  214.                       (cond ((or (file-directory-p bd-expn)
  215.                                  (and ok-create
  216.                                       (not (file-exists-p bd-expn))
  217.                                       (bkup-try-making-directory bd-noslash)))
  218.                              (setq bk-dir  (concat bd-noslash "/")
  219.                                    bk-base (bkup-backup-basename file full-path)))
  220.                             ((and bd-rel-p search-upward)
  221.                              (let ((bd-up (bkup-search-upward-for-backup-dir dir bd)))
  222.                                (if bd-up
  223.                                    (setq bk-dir (concat bd-up "/")
  224.                                          bk-base (bkup-backup-basename file full-path)))))))))
  225.             (setq alist (cdr alist))))
  226.       (if (and bk-dir bk-base)
  227.           (cons bk-dir bk-base)
  228.         (cons dir (bkup-backup-basename file nil))))))
  229.  
  230.  
  231. ;;; This next one is based on the following from `files.el'
  232. ;;; but accepts a second optional argument
  233.  
  234. ;;(defun make-backup-file-name (file)
  235. ;;  "Create the non-numeric backup file name for FILE.
  236. ;;This is a separate function so you can redefine it for customization."
  237. ;;  (if (and (eq system-type 'ms-dos)
  238. ;;       (not (msdos-long-file-names)))
  239. ;;      (let ((fn (file-name-nondirectory file)))
  240. ;;    (concat (file-name-directory file)
  241. ;;        (if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn)
  242. ;;            (substring fn 0 (match-end 1)))
  243. ;;        ".bak"))
  244. ;;    (concat file "~")))
  245.  
  246. (defun bkup-make-backup-file-name (file &optional dir-n-base)
  247.   "Create the non-numeric backup file name for FILE.
  248. Optionally accept a list containing the backup directory and
  249. backup basename.  NB: we don't really handle ms-dos."
  250.   (if (and (eq system-type 'ms-dos)
  251.        (not (and (fboundp 'msdos-long-file-names) (msdos-long-file-names))))
  252.       (let ((fn (file-name-nondirectory file)))
  253.     (concat (file-name-directory file)
  254.         (if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn)
  255.             (substring fn 0 (match-end 1)))
  256.         ".bak"))
  257.     (let ((d-n-b (or dir-n-base
  258.                      (bkup-backup-directory-and-basename file))))
  259.       (concat (car d-n-b) (cdr d-n-b) "~"))))
  260.  
  261. (defun bkup-existing-backup-files (fn)
  262.   "Return list of existing backup files for file"
  263.   (let* ((efn (expand-file-name fn))
  264.          (dir-n-base (bkup-backup-directory-and-basename efn))
  265.          (non-num-bk-name (bkup-make-backup-file-name efn dir-n-base))
  266.          (non-num-bk (file-exists-p non-num-bk-name))
  267.          (backup-dir (car dir-n-base))
  268.          (base-versions (concat (cdr dir-n-base) ".~"))
  269.          (possibilities (file-name-all-completions base-versions backup-dir))
  270.          (poss (mapcar #'(lambda (name) (concat backup-dir name)) possibilities)))
  271.     (mapcar #'expand-file-name
  272.             (if non-num-bk (cons non-num-bk-name poss) poss))))
  273.  
  274. (defun find-file-latest-backup (file)
  275.   "Find the latest backup file for FILE"
  276.   (interactive (list (read-file-name (format "Find latest backup of file (default %s): "
  277.                                              (file-name-nondirectory (buffer-file-name)))
  278.                                      nil (buffer-file-name) t)))
  279.   (let ((backup (file-newest-backup file)))
  280.     (if backup
  281.         (find-file backup)
  282.       (message "no backups found for `%s'" file))))
  283.  
  284.  
  285. ;;; Functions changed from `files.el' and elsewhere -- originals precede new versions
  286.  
  287. ;;(defun make-backup-file-name (file)
  288. ;;  "Create the non-numeric backup file name for FILE.
  289. ;;This is a separate function so you can redefine it for customization."
  290. ;;  (if (and (eq system-type 'ms-dos)
  291. ;;       (not (msdos-long-file-names)))
  292. ;;      (let ((fn (file-name-nondirectory file)))
  293. ;;    (concat (file-name-directory file)
  294. ;;        (if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn)
  295. ;;            (substring fn 0 (match-end 1)))
  296. ;;        ".bak"))
  297. ;;    (concat file "~")))
  298.  
  299. (defun make-backup-file-name (file)
  300.   "Create the non-numeric backup file name for FILE.
  301. This is a separate function so you can redefine it for customization.
  302. *** Changed by \"backup-dir.el\""
  303.   (bkup-make-backup-file-name file))
  304.  
  305.  
  306. ;;(defun find-backup-file-name (fn)
  307. ;;  "Find a file name for a backup file, and suggestions for deletions.
  308. ;;Value is a list whose car is the name for the backup file
  309. ;; and whose cdr is a list of old versions to consider deleting now.
  310. ;;If the value is nil, don't make a backup."
  311. ;;  (let ((handler (find-file-name-handler fn 'find-backup-file-name)))
  312. ;;    ;; Run a handler for this function so that ange-ftp can refuse to do it.
  313. ;;    (if handler
  314. ;;    (funcall handler 'find-backup-file-name fn)
  315. ;;      (if (eq version-control 'never)
  316. ;;      (list (make-backup-file-name fn))
  317. ;;    (let* ((base-versions (concat (file-name-nondirectory fn) ".~"))
  318. ;;           ;; used by backup-extract-version:
  319. ;;           (bv-length (length base-versions))
  320. ;;           possibilities
  321. ;;           (versions nil)
  322. ;;           (high-water-mark 0)
  323. ;;           (deserve-versions-p nil)
  324. ;;           (number-to-delete 0))
  325. ;;      (condition-case ()
  326. ;;          (setq possibilities (file-name-all-completions
  327. ;;                   base-versions
  328. ;;                   (file-name-directory fn))
  329. ;;            versions (sort (mapcar
  330. ;;                    #'backup-extract-version
  331. ;;                    possibilities)
  332. ;;                   '<)
  333. ;;            high-water-mark (apply #'max 0 versions)
  334. ;;            deserve-versions-p (or version-control
  335. ;;                       (> high-water-mark 0))
  336. ;;            number-to-delete (- (length versions)
  337. ;;                    kept-old-versions kept-new-versions -1))
  338. ;;        (file-error
  339. ;;         (setq possibilities nil)))
  340. ;;      (if (not deserve-versions-p)
  341. ;;          (list (make-backup-file-name fn))
  342. ;;        (cons (concat fn ".~" (int-to-string (1+ high-water-mark)) "~")
  343. ;;          (if (and (> number-to-delete 0)
  344. ;;               ;; Delete nothing if there is overflow
  345. ;;               ;; in the number of versions to keep.
  346. ;;               (>= (+ kept-new-versions kept-old-versions -1) 0))
  347. ;;              (mapcar #'(lambda (n)
  348. ;;                  (concat fn ".~" (int-to-string n) "~"))
  349. ;;                  (let ((v (nthcdr kept-old-versions versions)))
  350. ;;                (rplacd (nthcdr (1- number-to-delete) v) ())
  351. ;;                v))))))))))
  352.  
  353. (defun find-backup-file-name (fn)
  354.   "Find a file name for a backup file, and suggestions for deletions.
  355. Value is a list whose car is the name for the backup file
  356.  and whose cdr is a list of old versions to consider deleting now.
  357. If the value is nil, don't make a backup.
  358. *** Changed by \"backup-dir.el\""
  359.   (let ((handler (find-file-name-handler fn 'find-backup-file-name)))
  360.     ;; Run a handler for this function so that ange-ftp can refuse to do it.
  361.     (if handler
  362.     (funcall handler 'find-backup-file-name fn)
  363.       (if (eq version-control 'never)
  364.       (list (make-backup-file-name fn))
  365.     (let* ((dir-n-base (bkup-backup-directory-and-basename fn))         ;add
  366.                (non-num-bk-name (bkup-make-backup-file-name fn dir-n-base)) ;add
  367.                (bk-dir  (car dir-n-base))                                   ;add
  368.                (bk-base (cdr dir-n-base))                                   ;add
  369.                (base-versions (concat bk-base ".~"))                        ;mod
  370.            ;; used by backup-extract-version:
  371.            (bv-length (length base-versions))
  372.            possibilities
  373.            (versions nil)
  374.            (high-water-mark 0)
  375.            (deserve-versions-p nil)
  376.            (number-to-delete 0))
  377.       (condition-case ()
  378.           (setq possibilities (file-name-all-completions
  379.                    base-versions
  380.                    bk-dir)                                  ;mod
  381.             versions (sort (mapcar
  382.                     #'backup-extract-version
  383.                     possibilities)
  384.                    '<)
  385.             high-water-mark (apply #'max 0 versions)
  386.             deserve-versions-p (or version-control
  387.                        (> high-water-mark 0))
  388.             number-to-delete (- (length versions)
  389.                     kept-old-versions kept-new-versions -1))
  390.         (file-error
  391.          (setq possibilities nil)))
  392.       (if (not deserve-versions-p)
  393.           (list (bkup-make-backup-file-name fn dir-n-base))             ;mod
  394.         (cons (concat bk-dir base-versions (int-to-string (1+ high-water-mark)) "~") ;mod
  395.           (if (and (> number-to-delete 0)
  396.                ;; Delete nothing if there is overflow
  397.                ;; in the number of versions to keep.
  398.                (>= (+ kept-new-versions kept-old-versions -1) 0))
  399.               (mapcar #'(lambda (n)
  400.                   (concat bk-dir base-versions (int-to-string n) "~")) ;mod
  401.                   (let ((v (nthcdr kept-old-versions versions)))
  402.                 (rplacd (nthcdr (1- number-to-delete) v) ())
  403.                 v))))))))))
  404.  
  405.  
  406. ;;(defun file-newest-backup (filename)
  407. ;;  "Return most recent backup file for FILENAME or nil if no backups exist."
  408. ;;  (let* ((filename (expand-file-name filename))
  409. ;;     (file (file-name-nondirectory filename))
  410. ;;     (dir  (file-name-directory    filename))
  411. ;;     (comp (file-name-all-completions file dir))
  412. ;;     newest tem)
  413. ;;    (while comp
  414. ;;      (setq tem (car comp)
  415. ;;        comp (cdr comp))
  416. ;;      (cond ((and (backup-file-name-p tem)
  417. ;;          (string= (file-name-sans-versions tem) file))
  418. ;;         (setq tem (concat dir tem))
  419. ;;         (if (or (null newest)
  420. ;;             (file-newer-than-file-p tem newest))
  421. ;;         (setq newest tem)))))
  422. ;;    newest))
  423.  
  424. (defun file-newest-backup (filename)
  425.   "Return most recent backup file for FILENAME or nil if no backups exist.
  426. *** Changed by \"backup-dir.el\""
  427.   (let ((comp (bkup-existing-backup-files filename))
  428.         (newest nil)
  429.         (file nil))
  430.     (while comp
  431.       (setq file (car comp)
  432.         comp (cdr comp))
  433.       (if (and (backup-file-name-p file)
  434.            (or (null newest) (file-newer-than-file-p file newest)))
  435.       (setq newest file)))
  436.     newest))
  437.  
  438.  
  439. ;;; patch `latest-backup-file' from "dired"
  440. ;;;
  441. ;;; we use `dired-load-hook' to avoid loading dired now.  This speeds things up
  442. ;;; considerably according to Thomas Feuster, feuster@tp4.physik.uni-giessen.de
  443. ;;;
  444. ;;; one really wonders why there are 3 functions to do the same thing...
  445. ;;;
  446. (defun bkup-patch-latest-backup-file ()
  447.   (fset 'latest-backup-file (symbol-function 'file-newest-backup))
  448.   (remove-hook 'dired-load-hook 'bkup-patch-latest-backup-file))
  449.  
  450. (if (featurep 'dired)
  451.     ;; if loaded, patch it now
  452.     (fset 'latest-backup-file (symbol-function 'file-newest-backup))
  453.   ;; otherwise do it later
  454.   (add-hook 'dired-load-hook 'bkup-patch-latest-backup-file))
  455.  
  456.  
  457. ;;; patch `diff-latest-backup-file' from "diff"
  458. ;;;
  459. (require 'diff)
  460. (fset 'diff-latest-backup-file (symbol-function 'file-newest-backup))
  461.  
  462.  
  463. ;;; finally, add to list of features
  464. ;;;
  465. (provide 'backup-dir)
  466.  
  467. ;;; backup-dir.el ends here
  468.